MODULE fmm_box_to_raw_map_builder

! Module to build a map between one set of boxed parameters and all
! the sets of raw parameters that contribute to that box and branch.
! i.e. for given boxed moment, a linked list is generated of all the
! raw (unboxed) moments contributing to it.  
! Note this mapping will break if the raw_paras array is subsequently 
! rearranged or sorted.

   USE fmm_global_consts
   USE fmm_global_types
   IMPLICIT NONE
   PRIVATE
   ! Public procedures
   PUBLIC :: fmm_get_box_compression_map,      &
             fmm_free_box_compression_map

CONTAINS

!-------------------------------------------------------------------------------
! Routine to collect together raw_paras contributing to the same
! boxed moment (given by "map_up").

   SUBROUTINE fmm_get_box_compression_map(data)

      IMPLICIT NONE
      TYPE(gen_mm_paras), INTENT(INOUT) :: data
      INTEGER(INTK) :: i, id

      IF (ASSOCIATED(data%box_map)) CALL fmm_quit('map should not be built!')
      IF (.NOT.ASSOCIATED(data%raw_paras)) CALL fmm_quit('need raw paras map!')
      ALLOCATE(data%box_map(SIZE(data%box_paras)))

      DO i = 1, SIZE(data%box_paras) 
         NULLIFY(data%box_map(i)%head)
         data%box_map(i)%occ = 0
      END DO
 
      DO i = 1, SIZE(data%raw_paras) 
         ! use "map_up" to identify common box and branch elements
         id = data%raw_paras(i)%map_up
         IF (id == 0) CALL fmm_quit ('must build packed paras first!')
         ! add new element to list of occupants
         IF (data%box_map(id)%occ == 0) THEN
            ! linked list for this box is empty so start one
            data%box_map(id)%occ = 1
            ALLOCATE(data%box_map(id)%head)
            data%box_map(id)%head%id = i
            NULLIFY(data%box_map(id)%head%next)   ! list is empty
         ELSE
            ! make new entry and pre-pend to existing list
            CALL add_item(data%box_map(id),i)
         END IF
      END DO

!   call print_map(data%box_map,data%raw_paras)

   CONTAINS

      SUBROUTINE add_item(box_map,raw_id)
   
         IMPLICIT NONE
         TYPE(id_list), INTENT(INOUT) :: box_map
         INTEGER(INTK), INTENT(IN) :: raw_id
         TYPE(id_node), POINTER :: new_node
   
         box_map%occ = box_map%occ + 1
         ALLOCATE(new_node)
         new_node%id = raw_id
         IF (ASSOCIATED(box_map%head%next)) THEN
            ! more than one entry in list (including head)
            ! so point new_node to old second entry
            new_node%next => box_map%head%next
            ! point head to new_node
            NULLIFY(box_map%head%next)
            box_map%head%next => new_node
         ELSE
            ! only head so far; make new_node our second entry
            box_map%head%next => new_node
            NULLIFY(new_node%next)   ! end of list
         END IF
   
      END SUBROUTINE add_item

   END SUBROUTINE fmm_get_box_compression_map

!-------------------------------------------------------------------------------

   SUBROUTINE fmm_free_box_compression_map(box_map)

      IMPLICIT NONE
      TYPE(id_list), POINTER :: box_map(:)
      INTEGER(INTK) :: i

      IF (.NOT.ASSOCIATED(box_map)) RETURN  ! map not in fact built
      DO i = 1, SIZE(box_map)
         IF (box_map(i)%occ == 0) STOP 'should not have 0 occupancy'
         CALL free_linked_list(box_map(i)%head)
      END DO
      DEALLOCATE(box_map)
      NULLIFY(box_map)

   END SUBROUTINE fmm_free_box_compression_map

!-------------------------------------------------------------------------------

   RECURSIVE SUBROUTINE free_linked_list(occ_node)

      TYPE(id_node), POINTER :: occ_node

      ! traverse linked-list freeing from bottom up recursively
      IF (ASSOCIATED(occ_node%next)) THEN
         CALL free_linked_list(occ_node%next)
         IF (ASSOCIATED(occ_node)) DEALLOCATE(occ_node)
         NULLIFY(occ_node)
      END IF
      IF (ASSOCIATED(occ_node)) DEALLOCATE(occ_node)
      NULLIFY(occ_node)   

   END SUBROUTINE free_linked_list

!-------------------------------------------------------------------------------

   subroutine print_map(map,raw_paras)

      implicit none
      type(raw_mm_paras), intent(in) :: raw_paras(:) 
      type(id_list), intent(in) :: map(:)
      type(id_node), pointer :: ptr
      integer(intk) :: i

      write (IO1,*) "printing map:"
      do i = 1, size(map)
         write(IO1,*)
         ptr => map(i)%head
         do 
            write(IO1,'(2I5,5X,I5,3X,3I5)') i, ptr%id, &
                         raw_paras(ptr%id)%bra, raw_paras(ptr%id)%box
            if (.not.associated(ptr%next)) exit 
            ptr => ptr%next
         end do
      end do

   end subroutine print_map

!-------------------------------------------------------------------------------

END MODULE fmm_box_to_raw_map_builder

